(* Creme Caramel Compiler (Triple C) - Michele Caceffo - 2008 *)

open Exceptions;;
open Syntaxtree;;
open Intermediate;;
open Declaration;;
open Expressions;;
open Print;;
open Printf;;

(** Contains all the functions to generate the tagret code from the intermediate code instructions list 
    All this methods return unit, or the string which has to be printed out
*)

let nullpointer = "-STACK_SIZE-1" (* LDL: define a sound value for the null pointer *)

(** The header of the target code *)
(* LDL: refactor the code in order to have pointers to memory locations as value for memory locations *)
let header =
  "#include <stdio.h>
   #include <stdlib.h>
   
   #define STACK_SIZE 10240
   #define REG_SIZE 1024
   
   typedef int offset; /* LDL: we claim pointers to be identified by integer offsets on the stack */

   union memory_t_union {
       int i;
       float f;
       offset p;
   };
   typedef union memory_t_union memory_t;
   
   memory_t stack[STACK_SIZE];
   memory_t reg[REG_SIZE];
   
  "

(** Initialize a new stack-pointer 
    @param n The stack-pointer's initial value
*)
let newstack_pointer (n: int) = "\tint stackptr;\n stackptr = baseptr;\n\tstackptr += " ^ (string_of_int (n)) ^ ";\n"

(** The signature of the main function, with the first instructions for initialization
    @param n The number of global variables, used to initialize the stack-pointer's value
*)
let main_start (n: int) = "\nint main(int argc, char** argv) {
\tint baseptr;
\tint stackptr;
\tbaseptr = 0;
\tstackptr = " ^ (string_of_int n) ^ ";\n"

(** The end of the main *)
let main_end = "\n}\n"

(** Used to recover the type of data contained into an element (int or float) 
    @param e The element to check
    @raise TYPE_ERROR If the program is unable to retrive the type
*)
(* LDL: add the corresponding type checks for pointers *)
let getElementType (e: element) = match e with
          Reg(r,t)  ->  (
                         match t with
                            DInt         ->  ".i"
                          | DFloat       ->  ".f"
			  | DPointer(_)  ->  ".p"
                          | _            ->  raise (TYPE_ERROR "Unable to retrieve data type")
                        )
        | Off(o,tp,_) ->  (
                         match tp with
                            DInt         ->  ".i"
                          | DFloat       ->  ".f"
			  | DPointer(_)  ->  ".p"
                          | _            ->  raise (TYPE_ERROR "Unable to retrieve data type")
                        )
        | Val(v)    ->  (
                         match v with
                            I(n)    ->  ".i"
                          | F(r)    ->  ".f"
			  | O(_)    ->  ".p"
			  | ONull   ->  ".p"
                        )
        | _         ->  raise (TYPE_ERROR "Unable to retrieve data type")

(* LDL: add the new function to get the c_string for the reference operation *)
(** Used to calculate the 'address' for a variable, it corresponds to the @ operation
    @param v The variable whose address we are interested in
    @raise CONFIRM_RULE If this method is called for something that is not a variable (never occurs)
*)
let pointer_ref (v: element) = match v with
(* LDL: since we are expecting a single variable here, v should be an offset on the stack. This offset has to be output.
        Note that we are not interested in the type of the variable at all, this is becouse every cell on the stack
         has the same size.
 *)
    Off(o,_,b)     ->  if b then "baseptr + " ^ (string_of_int o) else (string_of_int o)
  | _              ->  (raise (CONFIRM_RULE "Here we are expecting a variable, this exception never occurs"))

(* LDL: add the new function to get the c_string for the dereference operation *)
(** Used to resolve the pointed 'address' of a variable on the stack, it corresponds to the ^ operation
    @param v The variable whose value will get us to the stack address we are interested in
    @raise CONFIRM_RULE If this method is called for something that is not a variable (never occurs)
*)
let pointer_deref (v: element) = 
  let string_address, type_of_variable =  match v with
    (* LDL: we are expecting a value of a cell in the stack here that we want to dereference *)
    | Reg(r,DPointer(pt))         ->  ("reg[" ^ (string_of_int r) ^ "].p"), pt
    | Off(o,DPointer(pt),b) as a  ->  if b then ("stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType a)), pt
                                      else ("stack[" ^ (string_of_int o) ^ "]" ^ (getElementType a)), pt
    | _                           ->  (raise (CONFIRM_RULE "Here we are expecting an offset on the stack, this exception never occurs"))
  in
  let c_record_type = match type_of_variable with
      DInt         ->  ".i"
    | DFloat       ->  ".f"
    | DPointer(_)  ->  ".p"
    | _            ->  raise (TYPE_ERROR "Unable to retrieve data type")
  in
  ("stack[" ^ string_address ^ "]" ^ c_record_type)

(** If the element is a declared variable, then if the boolean stored into the element is true (which means that
    is an element declared into a function/procedure) we have to calculate the offset from the basepointer, 
    otherwise we calculate it directly into the stack. Positive offsets are for variables, negative for parameters
    @param e The element to recover
    @raise TYPE_ERROR If the program is unable to find the type (e.g. the type is Bool, but into the memory there 
                      are only int, float and pointer offsets)
*)
(* LDL: update the c_element function in order to consider the introduction of pointer type values into the code structures *)
let c_element (e: element): string = match e with
          Reg(r,t)      ->  (
                             match t with
                                DInt         ->  "reg[" ^ (string_of_int r) ^ "]" ^ (getElementType e)
                              | DFloat       ->  "reg[" ^ (string_of_int r) ^ "]" ^ (getElementType e)
                              | DPointer(_)  ->  "reg[" ^ (string_of_int r) ^ "]" ^ (getElementType e)
                              | _            ->  raise (TYPE_ERROR "Unable to retrieve data type")
                            )
        | Off(o,tp,b)   ->  (
                             match tp with
                                DInt         ->  if b then "stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType e)
                                                 else "stack[" ^ (string_of_int o) ^ "]" ^ (getElementType e) 
                              | DFloat       ->  if b then "stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType e)
                                                 else "stack[" ^ (string_of_int o) ^ "]" ^ (getElementType e) 
                              | DPointer(_)  ->  if b then "stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType e)
                                                 else "stack[" ^ (string_of_int o) ^ "]" ^ (getElementType e) 
                              | _            ->  raise (TYPE_ERROR "Unable to retrieve data type")
                            )
        | Label(l)      ->  "L" ^ (string_of_int l) ^ " "
        | Val(v)        ->  (
                             match v with
                                I(n)    ->  string_of_int n
                              | F(r)    ->  string_of_float r
			      | O(p)    ->  string_of_offset p
			      | ONull    ->  nullpointer
                            )
        | Subr(s)       ->  s ^ "(stackptr);\n"
        | Null          ->  ""

(** Used to calculate the offset for a vector, with the same controls used for normal elements
    @param v The offset for the vector
    @param x The offset from the vector to the selected element
    @raise CONFIRM_RULE If this method is called for something that is not a vector (never occurs)
*)
let array_get (v: element) (x: element) = match v with
          Off(o,DInt,b)         ->  if b then "stack[baseptr + " ^ (string_of_int o) ^ " + " ^ (c_element x) ^ "].i"
                                    else "stack[" ^ (string_of_int o) ^ " + " ^ (c_element x) ^ "].i"
        | Off(o,DFloat,b)       ->  if b then "stack[baseptr + " ^ (string_of_int o) ^ " + " ^ (c_element x) ^ "].f"
                                    else "stack[" ^ (string_of_int o) ^ " + " ^ (c_element x) ^ "].f"
        | Off(o,DPointer(_),b)  ->  if b then "stack[baseptr + " ^ (string_of_int o) ^ " + " ^ (c_element x) ^ "].p"
                                    else "stack[" ^ (string_of_int o) ^ " + " ^ (c_element x) ^ "].p"	
        | _                     ->  (raise (CONFIRM_RULE "The vector instruction is built in a smart way, so this case never occurs :)"))

(** If the c element is null, it means that the subroutine is void, so we have only to call it, otherwise c is the 
    temporary variable where the return value is stored
    @param a The function call
    @param c The (optional) return register
*)
let c_subroutine (a: element) (c: element) : string = match c with
          Null  ->  (c_element a)
        | _     ->  (c_element c) ^ "\t=\t" ^ (c_element a)

(* LDL: this function is supposed do add checks to the C code in order to avoid invalid stack indexes to be used.
        Note that we distinguish over 4 kind of instructions: the tree which can contain either a '=', a '<', a '>'
        operator (for which we could have two stack[i] expressions, one on the left, one on the right) and the ones which
        does not. Note that '<=' and '=>' expressions can be left to the game of '=' with no danger.
 *)
let check_invalid_idx instruction =
  let count_unmatched_chars_before str c match_c stop =
    let rec count_unmatched_chars_before_aux str c match_c idx acc =
      if idx = (String.length str) then
	acc
      else
	if (str.[idx] = c) then
	  count_unmatched_chars_before_aux str c match_c (idx+1) (acc+1)
	else if (str.[idx] = match_c) && (acc > 0) then
	  count_unmatched_chars_before_aux str c match_c (idx+1) (acc-1)
	else
	  count_unmatched_chars_before_aux str c match_c (idx+1) acc
    in
    count_unmatched_chars_before_aux (String.sub str 0 stop) c match_c 0 0
  in
  let rec check_invalid_idx_aux instruction =
    let b1 = (String.contains instruction '=') and b2 = (String.contains instruction '<') and b3 = (String.contains instruction '>') and
	b4 = (String.contains instruction '+') and b5 = (String.contains instruction '-') and b6 = (String.contains instruction '*') and
	b7 = (String.contains instruction '/') and b8 = (String.contains instruction '&') and b9 = (String.contains instruction '|')
    in
    if (b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9) then
      let split_char =
	(
	  if b1 then '='
	  else if b2 then '<'
	  else if b3 then '>'
	  else if b4 then '+'
	  else if b5 then '-'
	  else if b6 then '*'
	  else if b7 then '/'
	  else if b8 then '&'
	  else (*if b9 then*) '|'
	)
      in
	(* LDL: split it and make checks on the left side first (since split_char is left associative for sure in this aux function) *)
      let splitter = String.index instruction split_char in (* LDL: note we are guaranted for splitter to exist *)
      let ls = (String.sub instruction 0 splitter) and
	  rs = (String.sub instruction (splitter+1) ((String.length instruction) - (splitter+1)))
      in 
      check_invalid_idx_aux ls ^ "\n" ^
	check_invalid_idx_aux rs ^ "\n"      
    else
      try 
	let index = (Str.search_forward (Str.regexp "stack\\[") instruction 0) in
	let nesting_factor = count_unmatched_chars_before instruction '[' ']' index in
	for i=1 to nesting_factor do
	  let rindex = String.rindex instruction ']' in
	  instruction.[rindex] <- ')' (* LDL: here ')' is just a wildcard to get rid of ']'s *)
	done;
	let string_for_the_index = (String.sub instruction (index+6) ((String.rindex instruction ']')-(index+6))) in
	(check_invalid_idx_aux string_for_the_index) ^
	  "\n" ^ "if (" ^ string_for_the_index ^ " < 0) {" ^ "\n" ^
	  "\tprintf(" ^ "\"Impossible to retrieve the value: maybe you forgot to assign a value to a pointer before dereferencing\\n\"" ^ ");" ^ "\n" ^
	  "\texit(-1);" ^ "\n" ^
	  "}"
      with Not_found -> ""
    in
  if (String.contains instruction '=') then 
      (* LDL: split it and make checks on the right side first (since '=' is right associative) *)
      let splitter = String.index instruction '=' in (* LDL: note we are guaranted for splitter to exist *)
      let ls = (String.sub instruction 0 splitter) and rs = (String.sub instruction (splitter+1) ((String.length instruction) - (splitter+1))) in
      check_invalid_idx_aux rs ^ "\n" ^
  	check_invalid_idx_aux ls ^ "\n" ^
  	instruction
  else check_invalid_idx_aux instruction ^ "\n" ^ instruction

(** Conver the intermediate code instructions into the target code instructions 
    @param i The instruction to convert
    @param out The output channel
    @param proct The subroutines table
    @raise CONFIRM_RULE If the OUT instruction is called with something that is not a variable (never occurs)
*)
(* LDL: update the instruction set with the dynamic semantics of REF and DEREF and CPY2PT and SETNULL
         Semantics is intuitively:
           @ <variable> : REF   <variable> NULL <dest> -> put address of <variable> into <dest>
           ^ <variable> : DEREF <variable> NULL <dest> -> follow the address in variable and give the value of the pointed variable
        Also make checs that no invalid dereferences are done on the stack.
*)
let c_instruction (i: instruction) (out: out_channel) (proct: proc_table)  =
  let instruction_str = match i with
          (CPY,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ ";\n")
        | (CPY2PT,a,_,c)    ->  check_invalid_idx ((pointer_deref c) ^ "\t=\t" ^ (c_element a) ^ ";\n")
	| (SETNULL,_,_,c)   ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (nullpointer) ^ ";\n")
        | (AGET,a,b,c)      ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (array_get a b) ^ ";\n")
        | (ASET,a,b,c)      ->  check_invalid_idx ((array_get a b) ^ "\t=\t" ^ (c_element c) ^ ";\n")
        | (ADD,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "+" ^ (c_element b) ^ ";\n")
        | (SUB,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "-" ^ (c_element b) ^ ";\n")
        | (MUL,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "*" ^ (c_element b) ^ ";\n")
        | (DIV,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "/" ^ (c_element b) ^ ";\n")
        | (AND,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "&&" ^ (c_element b) ^ ";\n")
        | (OR,a,b,c)        ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "||" ^ (c_element b) ^ ";\n")
        | (NOT,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "= !" ^ (c_element a) ^ ";\n")
        | (CEQU,a,b,c)      ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "==" ^ (c_element b) ^ ";\n")
        | (CNE,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ "!=" ^ (c_element b) ^ ";\n")
        | (CG,a,b,c)        ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ ">" ^ (c_element b) ^ ";\n")
        | (CGE,a,b,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (c_element a) ^ ">=" ^ (c_element b) ^ ";\n")
	| (REF,a,_,c)       ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (pointer_ref a) ^ ";\n")
	| (DEREF,a,_,c)     ->  check_invalid_idx ((c_element c) ^ "\t=\t" ^ (pointer_deref a) ^ ";\n")
        | (JNE,a,b,c)       ->  check_invalid_idx ("if (" ^ (c_element a) ^ "!=" ^ (c_element b) ^ ") goto " ^ (c_element c) ^ ";\n")
        | (GOTO,a,b,c)      ->  check_invalid_idx ("goto " ^ (c_element a) ^ ";\n")
        | (HALT,a,b,c)      ->  check_invalid_idx ("exit(0);\n")
        | (OUT,a,b,c)       ->  (
                                 match a with
                                    Reg(r,t)    ->  (
                                                     match t with
                                                          DInt         ->  check_invalid_idx ("printf(\"%d\\n\", reg[" ^ (string_of_int r) ^ "].i);\n")
                                                        | DFloat       ->  check_invalid_idx ("printf(\"%f\\n\", reg[" ^ (string_of_int r) ^ "].f);\n")
                                                        | DPointer(_)  ->  check_invalid_idx ("printf(\"%d\\n\", reg[" ^ (string_of_int r) ^ "].p);\n")
                                                        | _            ->  raise (TYPE_ERROR "Unable to retrieve data type")
                                                    )
                                  | Off(o,tp,b)   -> (match tp with
                                                         DInt   -> (
                                                                    if b then (
                                                                        (check_invalid_idx (
                                                                            "printf(\"%d\\n\", stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType a) ^ 
                                                                            ");\n"
                                                                        ))
                                                                    ) else (
                                                                        (check_invalid_idx (
                                                                            "printf(\"%d\\n\", stack[" ^ (string_of_int o) ^ "]" ^ (getElementType a) ^ ");\n"
                                                                        ))
                                                                    )
                                                                   )
                                                       | DFloat -> (
                                                                    if b then (
                                                                        (check_invalid_idx (
                                                                            "printf(\"%f\\n\", stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType a) ^ 
                                                                            ");\n"
                                                                            ))
                                                                    ) else (
                                                                        (check_invalid_idx (
                                                                            "printf(\"%f\\n\", stack[" ^ (string_of_int o) ^ "]" ^ (getElementType a) ^ ");\n"
                                                                        ))
                                                                    )
                                                                   )
                                                       | DPointer(_) -> (
                                                                          if b then (
                                                                              (check_invalid_idx (
                                                                                  "printf(\"%d\\n\", stack[baseptr + " ^ (string_of_int o) ^ "]" ^ (getElementType a) ^ 
                                                                                  ");\n"
                                                                                  ))
                                                                          ) else (
                                                                              (check_invalid_idx (
                                                                                  "printf(\"%d\\n\", stack[" ^ (string_of_int o) ^ "]" ^ (getElementType a) ^ ");\n"
                                                                              ))
                                                                          )
                                                                         )
                                                     | _         ->  raise (TYPE_ERROR "Unable to retrieve data type")
                                                    )
                                  | Val(I(v))   ->  check_invalid_idx ("printf(\"%d\\n\", " ^ (c_element a) ^ ");\n")
                                  | Val(F(v))   ->  check_invalid_idx ("printf(\"%f\\n\", " ^ (c_element a) ^ ");\n")
                                  | Val(O(_))   ->  check_invalid_idx ("printf(\"%d\\n\", " ^ (c_element a) ^ ");\n")
                                  | Val(ONull)  ->  check_invalid_idx ("printf(\"%d\\n\", " ^ (c_element a) ^ ");\n")
                                  | _           ->  (raise (CONFIRM_RULE "This case should never occur"))
                                )
        | (NOP,a,b,c)       ->  check_invalid_idx ("/* --- NOP --- */\n")
        | (PARAM,a,b,c)     ->  check_invalid_idx ("stack[stackptr++]" ^ (getElementType a) ^ "\t=\t" ^ (c_element a) ^ ";\n")
        | (CALL,a,b,c)      ->  check_invalid_idx (c_subroutine a c)
        | (RET,a,b,c)       ->  check_invalid_idx ("return " ^ (c_element a) ^ ";\n")
  in output_string out instruction_str

(** Generates the target code for all the elements of the instructions list
    @param il The list of instructions
    @param ic The intermediateCode class instance
    @param out The output channel
    @param n The index of the next instruction, used to check the label table
    @param proct The subroutines table
*)
let rec c_generator (il: instruction list) (ic: intermediateCode) (out: out_channel) (n: int) (proct: proc_table) = match il with
          []    ->  ()
        | i::is ->  (
                     if(ic#hasLabel n) then (
                        let l = (ic#getInstrLabel n) in
                        let rec string_join l j = match l with
                            []      ->  j
                          | x::xs   ->  string_join xs (j ^ x)
                        in
                        output_string out (string_join (List.map (fun x -> x ^ ":\n") (List.map c_element l)) "");
                     );
                     c_instruction i out proct;
                     c_generator is ic out (n+1) proct
                    )

(** Prints the return type of the subroutines
    @param r The return type
*)
let print_return (r: return): string = match r with
          SRet(Int)        ->  "int "
        | SRet(Float)      ->  "float "
	| SRet(UsrType(_)) ->  let msg = "It is not possible to return records from functions. " ^
				 "This point of target.ml is structurally unreachable becouse of static semantics."
			       in raise (CONFIRM_RULE msg)
        | Void             ->  "void "

(** Generates the target code for the subroutine prototype declaration, using the stored funUtils instance 
    @param out The output channel
    @param ic The intermediateCode class instance 
    @param proct The subroutines table
    @param Ide(id) The subroutine name
    @param p The entry binded with the subroutine name
    @raise CONFIRM_RULE When the proc_entry is Building (never occurs)
*)
let c_procedure_prototype (out: out_channel) (ic: intermediateCode) (proct: proc_table) (Ide(id): ide) (p: proc_entry) = match p with 
          Subroutine(r,dlist,dect,funcPar)  ->  (
                                                 output_string out ((print_return r) ^ (id) ^ "(int baseptr);\n\r";)
                                                )
        | Building(r,dlist)                 ->  raise (CONFIRM_RULE "Why should I have some subroutines in building phase here?")


(** Generates the target code for the subroutines, using the stored funUtils instance 
    @param out The output channel
    @param ic The intermediateCode class instance 
    @param proct The subroutines table
    @param Ide(id) The subroutine name
    @param p The entry binded with the subroutine name
    @raise CONFIRM_RULE When the proc_entry is Building (never occurs)
*)
let c_procedure (out: out_channel) (ic: intermediateCode) (proct: proc_table) (Ide(id): ide) (p: proc_entry) = match p with 
          Subroutine(r,dlist,dect,funcPar)  ->  (
                                                 let oldinstr = ic#getInstructionClass in (
                                                     ic#setInstructionClass funcPar;
                                                     print_DecTable (out) (dect);
                                                     output_string out (
                                                         (print_return r) ^ (id) ^ "(int baseptr) {\n" ^ 
                                                         (newstack_pointer ((Hashtbl.length dect) - List.length dlist))
                                                     );
                                                     c_generator (funcPar#getInl) (ic) (out) (0) proct;
                                                     output_string out "}\n\r";
                                                     ic#setInstructionClass oldinstr;
                                                 )
                                                )
        | Building(r,dlist)                 ->  raise (CONFIRM_RULE "Why should I have some subroutines in building phase here?")

(** Calls the c_procedure method for all the entries of the procedure table
    @param out The output channel
    @param proct The subroutines table
    @param ic The intermediateCode class instance
*)
let c_subroutines (out: out_channel) (proct: proc_table) (ic: intermediateCode) = (
		output_string out "\n\r";
		Hashtbl.iter (c_procedure_prototype out ic proct) proct;
        Hashtbl.iter (c_procedure out ic proct) proct;
)
